home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / examples.zoo / misc / sort1.lsp < prev    next >
Lisp/Scheme  |  1991-10-22  |  2KB  |  37 lines
  1. ; Eine Sortierfunktion, sortiert eine Liste und streicht dabei Doppelte.
  2. ; Für list destruktiv.
  3. ; comparefun realisiert eine Totalordnung: -1 oder 0 oder +1 als Ergebnis.
  4. ; Dabei gelten zwei Listenelemente als gleich, wenn comparefun 0 liefert.
  5. (defun sort-list-deleting-duplicates (list comparefun &key (key #'identity))
  6.   (let ((len (length list)))
  7.     (case len
  8.       (0 list) ; leere Liste unverändert
  9.       (1 list) ; einelementige Liste unverändert
  10.       (2 (case (funcall comparefun (funcall key (first list)) (funcall key (second list)))
  11.            (-1 list) ; Liste ist bereits sortiert
  12.            (0 (cdr list)) ; zwei gleiche, wird verkürzt
  13.            (+1 (setf (cddr list) list) (shiftf (cdr list) nil)) ; vertauschen
  14.       )  )
  15.       (t ; Liste mit >=2 Elementen
  16.          ; auseinanderdividieren in zwei Teile:
  17.          (let ((L1 list)
  18.                (L2 (shiftf (cdr (nthcdr (1- (ash len -1)) list)) nil)))
  19.            ; einzeln sortieren:
  20.            (setq L1 (sort-list-deleting-duplicates L1 comparefun :key key))
  21.            (setq L2 (sort-list-deleting-duplicates L2 comparefun :key key))
  22.            ; Nun sind L1 und L2 (jedes für sich) sortiert und ohne Doppelte.
  23.            ; zusammenmischen, dabei sortiert halten und gemeinsame Elemente
  24.            ; von L1 und L2 nur einmal übernehmen (dadurch enthält dann
  25.            ; auch die Gesamtliste keine Doppelten):
  26.            (setq list nil)
  27.            (loop
  28.              (when (null L1) (return (nreconc list L2)))
  29.              (when (null L2) (return (nreconc list L1)))
  30.              (case (funcall comparefun (funcall key (first L1)) (funcall key (first L2)))
  31.                (-1 (rotatef list L1 (cdr L1)))
  32.                (0 (pop L1) (rotatef list L2 (cdr L2)))
  33.                (+1 (rotatef list L2 (cdr L2)))
  34.            ) )
  35. ) ) ) )  )
  36.  
  37.